home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel0_89.lha
/
Feel
/
Modules
/
case.em
< prev
next >
Wrap
Lisp/Scheme
|
1993-07-12
|
4KB
|
131 lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; EuLisp Module Copyright (C) University of Bath 1991 ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; EuLisp Module - Copyright (C) Codemist and University of Bath 1990 ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Name: case ;;
;; ;;
;; Author: Keith Playford ;;
;; ;;
;; Date: 20 August 1990 ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Change Log:
;; Version 1.0 (20/8/90)
;;
(defmodule case
(standard) ()
(defun error (m c . i)
(signal (make-condition c 'message m) ()))
(defconstant *wild-card* 'else)
(defconstant *case-error* clock-tick)
(deflocal free-variables ())
(defun add-free-var (sym)
(setq free-variables (cons sym free-variables))
())
(defun reset-free-var ()
(setq free-variables ())
())
;; Match cases...
(defun symbol-matcher (sym)
(cond ((eq sym *wild-card*) (lambda (x) t))
(t (add-free-var sym)
`(lambda (@case-exp-part@) (setq ,sym @case-exp-part@) t))))
(defun constant-matcher (c)
`(lambda (@case-exp-part@) (equal @case-exp-part@ ,c)))
(defun sublist-matcher (l)
(cond ((null l) (constant-matcher nil))
(t `(lambda (@case-exp-part@)
(and (,(pattern-matcher (car l)) (car @case-exp-part@))
(,(sublist-matcher (cdr l)) (cdr @case-exp-part@)))))))
(defun list-matcher (l)
(let ((pats (cdr l)))
(cond ((consp pats)
`(lambda (@case-exp-part@)
(and (consp @case-exp-part@)
(= (list-length @case-exp-part@) ,(list-length pats))
(,(sublist-matcher pats) @case-exp-part@))))
(t (error "case: empty list pattern" *case-error*)))))
(defun cons-matcher (l)
(let ((pats (cdr l)))
(cond ((and (consp pats) (= (list-length pats) 2))
`(lambda (@case-exp-part@)
(and (consp @case-exp-part@)
(,(pattern-matcher (car l)) (car @case-exp-part@))
(,(pattern-matcher (cdr l)) (cdr @case-exp-part@))))))))
(defun vector-matcher (v)
(let ((pats (cdr l)))
(defun pattern-matcher (pat)
(cond ((consp pat)
(cond ((eqcar pat 'quote) (constant-matcher pat))
((eqcar pat 'list) (list-matcher pat))
((eqcar pat 'cons) (cons-matcher pat))
(t (error "case: unknown structure" *case-error*))))
(t (cond ((symbolp pat) (symbol-matcher pat))
(t (constant-matcher pat))))))
(defun vector-matcher (v))
;; Matcher generator...
(defun case-matcher (case)
(reset-free-var)
(let ((pat (car case))
(vals (cdr case)))
(let ((forms (pattern-matcher pat)))
`(((lambda ,free-variables
(if (,forms @case-exp@)
(progn
(setq @case-result@ (progn ,@vals))
t)
nil))
,@(mapcar (lambda (a) ()) free-variables)) nil))))
(defun case-matchers (cases)
(cond ((null cases) (list '(t (print "NO MATCH"))))
(t (cons (case-matcher (car cases))
(case-matchers (cdr cases))))))
;; Interface macro...
(defmacro case (exp . cases)
`(let ((@case-exp@ ,exp)
(@case-result@ ()))
(cond
,@(case-matchers cases))
@case-result@))
(export case)
)